Deutsche Edition 1/Deutsche Edition 1.iso/amok/amok_lha/amok46.lha/Module/AmigaGraphik.mod

Text File | 1993-08-15 | 14KB | 550 lines

(*
 * -------------------------------------------------------------------------
 *
 *    :Program.    AmigaGraphik.mod
 *    :Contents.    Proceduren zum Öffnen und Schließen von Windows und
 *    :Contents.    Screens, sowie einheitliche Zeichenoperationen.
 *    :Author.    Reiner Nix
 *    :Address.    Geranienhof 2, 5000 Köln 71 Seeberg
 *    :Copyright.    Public Domain
 *    :Language.    Modula-2
 *    :Translator.    M2Amiga A-L V3.3d
 *    :History.    V1.0    1.11.90
 *
 * -------------------------------------------------------------------------
 *)
IMPLEMENTATION MODULE AmigaGraphik;


FROM    SYSTEM          IMPORT  ADR;
FROM    Arts        IMPORT    Assert,BreakPoint;
FROM    Exec        IMPORT    Forbid, Permit, GetMsg, ReplyMsg;
FROM    Graphics        IMPORT  RastPortPtr,TextFontPtr,ViewPortPtr,
                                TextAttr,
                                SetRGB4,SetRast,SetFont,RectFill,Text;
FROM    Intuition       IMPORT  IDCMPFlags,IDCMPFlagSet,
                WindowFlags,WindowFlagSet,
                ScreenFlags,ScreenFlagSet,
                ScreenPtr,WindowPtr, IntuiMessagePtr,
                NewScreen,NewWindow,
                ModifyIDCMP;
FROM    DiskFont        IMPORT  OpenDiskFont;
IMPORT  Graphics;
IMPORT  GfxMacros;
IMPORT  Intuition;
FROM    Heap        IMPORT    Deallocate;
FROM    Str             IMPORT  Length;
FROM    Conversions     IMPORT  ValToStr;
FROM    IntuitionTools    IMPORT    initNewWindow;

(*
 *IMPORT    InOut;        (* Nur zum Testen mit Ausgabe() *)
 *)

CONST   stringWidth             = 20;
    NoWindow        ="Es ist kein Fenster geöffnet! [AG]";
    NoScreen        ="Es ist kein Bildschirm geöffnet! [AG]";
    None            ="Weder Fenster noch Schirm geöffnet! [AG]";

VAR     actualScreen            :ScreenPtr;
        actualWindow            :WindowPtr;
        actualRastPort          :RastPortPtr;
        actualViewPort          :ViewPortPtr;
        actualFont              :TextFontPtr;
        actualX, actualY,
        actualXMin,actualXMax,
        actualYMin,actualYMax,
        clipXMin,clipXMax,
        clipYMin,clipYMax       :INTEGER;
        HelpString              :ARRAY [0..stringWidth] OF CHAR;

(*
 * --------------------------------------------------------------------------
 * InLimits    prüft, ob Punkt zeichenbar, d.h. innerhalb ClipRegion und
 *        Window- / Screengröße liegt.
 * --------------------------------------------------------------------------
 *)
PROCEDURE InLimits              (    x,y                :INTEGER) :BOOLEAN;

BEGIN
RETURN (x >= actualXMin) AND (x <= actualXMax) AND
       (y >= actualYMin) AND (y <= actualYMax)
END InLimits;


PROCEDURE OpenScreen            (VAR newScreen          :NewScreen) :ScreenPtr;

BEGIN
RETURN Intuition.OpenScreen (newScreen)
END OpenScreen;


PROCEDURE CloseScreen           (VAR Screen             :ScreenPtr);

BEGIN
IF Screen # NIL THEN
  IF actualScreen = Screen THEN
    actualScreen := NIL
    END;
  Intuition.CloseScreen (Screen);
  Screen := NIL;
  END
END CloseScreen;


(*
 * --------------------------------------------------------------------------
 * NewScreenSize    passt die gewünschte ClipRegion der benutzbaren
 *            Screengröße an.
 * --------------------------------------------------------------------------
 *)
PROCEDURE NewScreenSize;

BEGIN
WITH actualScreen^ DO
  actualXMin            := clipXMin;
  actualXMax            := clipXMax;
  IF actualXMax >= width THEN
    actualXMax := width-1;
    IF actualXMin >= actualXMax THEN
      actualXMin := actualXMax-1
      END
    END;
  actualYMin            := clipYMin;
  actualYMax            := clipYMax;
  IF actualYMax >= height THEN
    actualYMax := height-1;
    IF actualYMin >= actualYMax THEN
      actualYMin := actualYMax-1
      END
    END
  END
END NewScreenSize;


PROCEDURE UseScreen             (    Screen             :ScreenPtr);

BEGIN
IF Screen = NIL THEN
  RETURN
  END;
WITH Screen^ DO
  actualScreen          := Screen;
  actualWindow          := NIL;
  actualRastPort        := ADR (rastPort);
  actualViewPort        := ADR (viewPort);
  actualX               := actualRastPort^.x;
  actualY               := actualRastPort^.y;
  NewScreenSize
  END
END UseScreen;


PROCEDURE OpenWindow            (VAR newWindow          :NewWindow) :WindowPtr;

VAR    Window    :WindowPtr;

BEGIN
Window := Intuition.OpenWindow (newWindow);
IF Window # NIL THEN
  Window^.userData := NIL
  END;
RETURN Window
END OpenWindow;


PROCEDURE OpenSimpleWindow    () :WindowPtr;

VAR    newWindow    :NewWindow;

BEGIN
initNewWindow (newWindow,0,0,640,256,0,1,
           IDCMPFlagSet {},
           WindowFlagSet {windowDepth,windowDrag,windowSizing},
           NIL,NIL,NIL,NIL,NIL,50,10,640,256,ScreenFlagSet {wbenchScreen});
RETURN OpenWindow (newWindow)
END OpenSimpleWindow;


PROCEDURE CloseWindow           (VAR Window             :WindowPtr);

VAR    i        :CARDINAL;
    Nachricht    :IntuiMessagePtr;

BEGIN
IF Window # NIL THEN                    (* AmigaGraphik *)
  IF actualWindow = Window THEN
    actualWindow := NIL
    END;
  IF superBitMap IN Window^.flags THEN            (* SuperBitMap? *)
    WITH Window^.wLayer^.superBitMap^ DO
      FOR i := 0 TO depth DO
        IF planes[i] # NIL THEN
          Deallocate (planes[i])
          END
        END
      END;
    Deallocate (Window^.wLayer^.superBitMap)
    END;
  IF Window^.userPort # NIL THEN            (* IntuiMessages *)
    Forbid ();
      REPEAT
      Nachricht := GetMsg (Window^.userPort);
      IF Nachricht # NIL THEN
        ReplyMsg (Nachricht)
        END
      UNTIL Nachricht = NIL;
    ModifyIDCMP (Window, IDCMPFlagSet {});
    Window^.userPort := NIL;
    Permit ()
    END;
  Intuition.CloseWindow (Window);            (* CloseWindow *)
  Window := NIL
  END
END CloseWindow;


(*
 * --------------------------------------------------------------------------
 * NewWindowSize    stellt die gewünschte ClipRegion auf die tatsächlich
 *            benutzbare Größe ein.
 * --------------------------------------------------------------------------
 *)
PROCEDURE NewWindowSize;

VAR    Breite, Hoehe    :INTEGER;

BEGIN
Assert (actualWindow # NIL, ADR (NoWindow));
WITH actualWindow^ DO
  IF superBitMap IN flags THEN
    Breite := wLayer^.superBitMap^.bytesPerRow*8;
    Hoehe := wLayer^.superBitMap^.rows
  ELSE
    Breite := width;
    Hoehe := height
    END;
  actualXMin            := clipXMin;
  actualXMax            := clipXMax;
  IF actualXMax >= Breite THEN
    actualXMax := Breite-1;
    IF actualXMin >= actualXMax THEN
      actualXMin := actualXMax-1
      END
    END;
  actualYMin            := clipYMin;
  actualYMax            := clipYMax;
  IF actualYMax >= Hoehe THEN
    actualYMax := Hoehe-1;
    IF actualYMin >= actualYMax THEN
      actualYMin := actualYMax-1
      END
    END
  END
END NewWindowSize;


PROCEDURE UseWindow             (    Window             :WindowPtr);

BEGIN
IF Window = NIL THEN
  RETURN
  END;
WITH Window^ DO
  actualScreen          := NIL;
  actualWindow          := Window;
  actualRastPort        := rPort;
  actualViewPort        := ADR (wScreen^.viewPort);
  actualX               := actualRastPort^.x;
  actualY               := actualRastPort^.y;
  NewWindowSize
  END
END UseWindow;


PROCEDURE OpenFont              (VAR textAttr           :TextAttr) :TextFontPtr;

VAR    Font    :TextFontPtr;

BEGIN
Font := Graphics.OpenFont (ADR (textAttr));
IF Font = NIL THEN
  Font := OpenDiskFont (ADR (textAttr))
  END;
RETURN Font
END OpenFont;


PROCEDURE CloseFont             (VAR Font               :TextFontPtr);

BEGIN
IF Font # NIL THEN
  IF actualFont = Font THEN
    actualFont := NIL
    END;
  Graphics.CloseFont (Font);
  Font := NIL
  END
END CloseFont;


PROCEDURE UseFont               (    Font               :TextFontPtr);

BEGIN
actualFont := Font;
IF (actualScreen # NIL) OR (actualWindow # NIL) THEN
  SetFont (actualRastPort, Font)
  END
END UseFont;


(*
 * --------------------------------------------------------------------------
 * SetClipRegion    stellt gewünschte ClipRegion ein, Mindestmaße sind:
 *            linke, obere Ecke bei (0,0) rechte, untere Ecke
 *            um ein größer.
 * --------------------------------------------------------------------------
 *)
PROCEDURE SetClipRegion         (    x1,y1, x2,y2       :INTEGER);

BEGIN
clipXMin := x1;   clipXMax := x2;
clipYMin := y1;   clipYMax := y2;
IF clipXMin < 0 THEN
  clipXMin := 0
  END;
IF clipXMax <= clipXMin THEN
  clipXMax := clipXMin+1
  END;
IF clipYMin < 0 THEN
  clipYMin := 0
  END;
IF clipYMax <= clipYMin THEN
  clipYMax := clipYMin+1
  END;
IF actualScreen # NIL THEN
  NewScreenSize
ELSIF actualWindow # NIL THEN
  NewWindowSize
  END
END SetClipRegion;


PROCEDURE SetColourReg          (    Register,
                                     Colour             :CARDINAL);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL), ADR (None));
Colour := Colour MOD 1000H;
SetRGB4 (actualViewPort,Register,
         Colour DIV 100H, Colour MOD 100H DIV 10H, Colour MOD 10H)
END SetColourReg;


PROCEDURE SetAPen               (    Register           :CARDINAL);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
Graphics.SetAPen (actualRastPort,Register)
END SetAPen;


PROCEDURE SetBPen               (    Register           :CARDINAL);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
Graphics.SetBPen (actualRastPort,Register)
END SetBPen;


PROCEDURE Clear                 (    Register           :CARDINAL);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
SetRast (actualRastPort,Register)
END Clear;


PROCEDURE WritePixel            (    x,y                :INTEGER);

VAR     Dummy :BOOLEAN;

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF InLimits (x,y) THEN
  Dummy := Graphics.WritePixel (actualRastPort,x,y)
  END;
actualX := x;  actualY := y
END WritePixel;


PROCEDURE Move                  (    x,y                :INTEGER);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF InLimits (x,y) THEN
  Graphics.Move (actualRastPort,x,y)
  END;
actualX := x;  actualY := y
END Move;


PROCEDURE ClipIt        (    g1,g2        :INTEGER;
                 VAR x1,y1, x2,y2    :INTEGER) :BOOLEAN;

BEGIN
IF    (g1 > 0) AND (g2 <= 0) THEN
  x2 := x1 + INTEGER (LONGINT (g1) * LONGINT (x2-x1) DIV LONGINT (g1-g2));
  y2 := y1 + INTEGER (LONGINT (g1) * LONGINT (y2-y1) DIV LONGINT (g1-g2));
ELSIF (g2 > 0) AND (g1 <= 0) THEN
  x1 := x2 + INTEGER (LONGINT (g2) * LONGINT (x1-x2) DIV LONGINT (g2-g1));
  y1 := y2 + INTEGER (LONGINT (g2) * LONGINT (y1-y2) DIV LONGINT (g2-g1))
  END;
RETURN (g1 > 0) OR (g2 > 0)
END ClipIt;


PROCEDURE Draw                  (    x,y                :INTEGER);

VAR     x1,y1 :INTEGER;

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
x1 := actualX;  y1 := actualY;
actualX := x;   actualY := y;
IF ClipIt (x1-actualXMin, x-actualXMin, x1,y1, x,y) AND
   ClipIt (actualXMax-x1, actualXMax-x, x1,y1, x,y) AND
   ClipIt (y1-actualYMin, y-actualYMin, x1,y1, x,y) AND
   ClipIt (actualYMax-y1, actualYMax-y, x1,y1, x,y) THEN
  Graphics.Move (actualRastPort,CARDINAL (x1),CARDINAL (y1));
  Graphics.Draw (actualRastPort,CARDINAL (x),CARDINAL (y))
  END
END Draw;


PROCEDURE DrawLine              (    x1,y1, x2,y2       :INTEGER);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
actualX := x2;   actualY := y2;
IF ClipIt (x1-actualXMin, x2-actualXMin, x1,y1, x2,y2) AND
   ClipIt (actualXMax-x1, actualXMax-x2, x1,y1, x2,y2) AND
   ClipIt (y1-actualYMin, y2-actualYMin, x1,y1, x2,y2) AND
   ClipIt (actualYMax-y1, actualYMax-y2, x1,y1, x2,y2) THEN
  Graphics.Move (actualRastPort,CARDINAL (x1),CARDINAL (y1));
  Graphics.Draw (actualRastPort,CARDINAL (x2),CARDINAL (y2))
  END
END DrawLine;


PROCEDURE DrawBox               (    x1,y1, x2,y2       :INTEGER);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
Move (x1,y1);
Draw (x1,y2);
Draw (x2,y2);
Draw (x2,y1);
Draw (x1,y1)
END DrawBox;


PROCEDURE DrawCircle            (    x,y, a             :INTEGER);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF InLimits (x-a,y-a) AND InLimits (x+a,y+a) THEN
  GfxMacros.DrawCircle (actualRastPort,x,y,a)
  END
END DrawCircle;


PROCEDURE DrawEllipse           (    x,y, a,b           :INTEGER);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF InLimits (x-a,y-b) AND InLimits (x+a,y+b) THEN
  Graphics.DrawEllipse (actualRastPort,x,y,a,b)
  END
END DrawEllipse;


PROCEDURE FillRectangle         (    x1,y1, x2,y2       :INTEGER);

VAR     h  :INTEGER;

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF x1 > x2 THEN
  h := x1; x1 := x2; x2 := h
  END;
IF y1 > y2 THEN
  h := y1; y1 := y2; y2 := h
  END;
IF (x2 < actualXMin) OR (y2 < actualYMin) OR
   (x1 > actualXMax) OR (y1 > actualYMax) THEN
  BreakPoint (ADR ("FillRectangle: außerhalb!"));
  RETURN
  END;
IF x1 < actualXMin THEN x1 := actualXMin END;
IF x2 > actualXMax THEN x2 := actualXMax END;
IF y1 < actualYMin THEN y1 := actualYMin END;
IF y2 > actualYMax THEN y2 := actualYMax END;
RectFill (actualRastPort,x1,y1,x2,y2)
END FillRectangle;


PROCEDURE Write                 (    char               :CHAR);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
HelpString[0] := char;
HelpString[1] := 0C;
Text (actualRastPort,ADR (HelpString),1)
END Write;


PROCEDURE WriteString           (    string             :ARRAY OF CHAR);

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
Text (actualRastPort,ADR (string),Length (string))
END WriteString;


PROCEDURE WriteInt              (    x, n               :LONGINT);

VAR     err  :BOOLEAN;

BEGIN
Assert ((actualScreen # NIL) OR (actualWindow # NIL),ADR (None));
IF    n > stringWidth THEN
  n := stringWidth
ELSIF n < -stringWidth THEN
  n := -stringWidth
  END;
ValToStr (x,TRUE,HelpString,10,n," ",err);
IF NOT err THEN
  Text (actualRastPort,ADR (HelpString),Length (HelpString))
  END
END WriteInt;


PROCEDURE WriteCard             (    x, n               :LONGCARD);

BEGIN
WriteInt (LONGINT (x), LONGINT (n))
END WriteCard;


BEGIN
actualScreen    := NIL;
actualWindow    := NIL;
actualRastPort  := NIL;
actualViewPort  := NIL;
actualFont      := NIL;
actualX         := 0;
actualY         := 0;
SetClipRegion (0,0,5000,5000)
END AmigaGraphik.